COMMENT ⊗   VALID 00014 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00003 00002	 data trasnfer macros: SNDINT,SNDFP
C00004 00003	 data transfer : PUSHINTI,ARTVAL,RTVAL,AGTVAL
C00008 00004		RTLEVS - returns leveloffset info of stack in integer buffer
C00010 00005		PAFFIX,PUNFIX
C00015 00006	 display: DISVT05
C00016 00007	 relative jumps: RFRCHK,RJMP,RJMPC
C00019 00008	 relative printing: RPRINT
C00020 00009	 supplementary motions: pmove,tadrive,tddrive,gather,rforce,setstf
C00024 00010	 supplementary functions: uparrow,dwnarrow,alpha,dollar,swap,vneg,vsmul,ftof
C00028 00011	 functions: sqrt,sin,cos,asin,acos,tan,atan2,log,exp
C00029 00012	 procedure handling: GTBLK
C00031 00013	 more stack ops: gtint,gvals,chngs
C00033 00014	 return from POINTY : pdone 
C00034 ENDMK
C⊗;
COMMENT ⊗ data trasnfer macros: SNDINT,SNDFP
	⊗

.MACRO	SNDINT X
	MOV  X,@INTPTR
	ADD  #2,INTPTR
	.ENDM

.MACRO	SNDFP X
	STF  X,@FPPTR
	ADD  #4,FPPTR
	.ENDM

.MACRO	SNDFIN X
	STCFI X,@INTPTR
	ADD   #2,INTPTR
	.ENDM
COMMENT	⊗ data transfer : PUSHINTI,ARTVAL,RTVAL,AGTVAL
 routines to facilitate data transfer to POINTY interface
	XX is scalar index; Y is leveloffset of array element

	AGTVAL XX,Y	= PUSHINTI XX; GTVAL Y
	ACHNGE XX,Y	= PUSHINTI XX; CHNGE Y
	ARTVAL XX,Y	= AGTVAL XX,Y; RTVAL

	RTVAL is used to transfer the top element of stack to the return buffer
	⊗;
PUSHINTI:
; The argument is an integer. Make a scalar out of it and
; push that scalar onto stack.

	FETCH R0
	LDCIF R0,AC0	;convert to real
	JSR PC,NOCMP
      	JSR PC,GETSCA	;R0 ← -(R3) ← LOC[new scalar block]
	STF AC0,@(R3)	;Store result
	JSR PC,YESCMP
	CCC		;Clear condition code.
	RTS PC		;Done


AGTVAL:	JSR	PC,PUSHINTI	; get value of index to array
	JMP	GTVAL		; now get the offset of the array

CCHNGE:	CLR	R0
	JSR	PC,COPY0	; copy value of top element in stack
	JMP	CHNGE		; now do the assignment

CACHNG:	CLR	R0
	JSR	PC,COPY0	; copy value of top element in stack
ACHNGE:	JSR	PC,PUSHINTI	; get value of index to array
	JMP	CHNGE		; now update value of the array

CRTVAL:	MOV	(R3),R0		; return top of stack without popping
	JMP	RTVAL0

ARTVAL:	JSR	PC,AGTVAL	; get the value of the array element
RTVAL:				; now output the value
	MOV	(R3)+,R0	; pop the top element  R0←loc[value cell]
RTVAL0:	MOV	#1,R1		; counter for counting number of elements
	CMPB	#TRNID,TAGID(R0)	;A trans?
	BEQ	1$
	CMPB	#VCTID,TAGID(R0)	;A vector?
	BEQ	2$
	BR	3$			;Must be a scalar
1$:	JSR	PC,EULER
	MOV	#EDAT,R0
	MOV	#4,R1
2$:	ADD	#2,R1

3$:	LDF	(R0)+,AC0		;load element into AC0
	STF	AC0,@FPPTR		;move it into return buffer
	ADD	#4,FPPTR		;update the pointer in the return buffer
	SOB	R1,3$			;get the next element
	RTS	PC

EULER:	MOV	#EDAT,R1
	JSR	PC,@LEULER	; now recorrect
	MOV	#EDAT+14,R1	; value of THETA
	LDF	(R1),AC0	; get value of O computed by euler in armcode
	SUBF	F90,AC0
	STF	AC0,(R1)+
	LDF	(R1),AC0	; PHI=A+90
	ADDF	F90,AC0
	STF	AC0,(R1)
	RTS	PC

DATA
F90:	.FLT2	90.0
F180:	.FLT2	180.0
EDAT:	.BLKW	30
YHAT:	.FLT2	0.0,1.0,0.0,1.0
ZHAT:	.FLT2	0.0,0.0,1.0,1.0
CODE
;	RTLEVS - returns leveloffset info of stack in integer buffer

RTLEVS:
COMMENT ⊗ Returns offset of top element in the stack if simple variable: if it is
	an array, returns the offset and the index sequentially.  This does not
	affect the stack. R0 and R1 are garbaged.
	⊗
	MOV R3,R1		;Use temporary stackpointer
	LDF @(R1)+,AC0		;Get value of top element of stack
	STCFI AC0,R0		;convert into integer and put in R0
	MOV R0,@INTPTR		;and store into integer buffer
	ADD #2,INTPTR		;and increment integer buffer pointer
	PUSH <R1>		;Since GETENV will clobber it
	JSR PC,GETENV		;Get the environment pointer in R0
	POP  <R1>		;TO recover R1
	BIT #ARYTYP,(R0)	;Do we have an array to access?
	BEQ 10$
	PUSH <R2>
	MOV 2(R0),R2		;R2 ← LOC[array header]
	MOV (R2)+,R0		;R0 ← # of dimensions of array
	POP  <R2>
3$:	LDF @(R1)+,AC0		;Get value of subscript
	STCFI AC0,@INTPTR	;Ship it into integer buffer
	ADD #2,INTPTR		;update the pointer
	SOB R0,3$		;Do all the subscripts
10$:	RTS PC			;Return with R0 and R1 garbaged
;	PAFFIX,PUNFIX

PAFFIX:
COMMENT ⊗ AFFIX together the two currently top elements
	and return their offsets in the integer buffer.
	⊗
	SNDINT #XAFFIX		;return affix code
	JSR PC,RTLEVS		;return the offset to the 10
	JSR PC,GTINT		;Get first frame offset
	JSR PC,GETARG		;R0 ← LOC[environment entry]
	BIT #HDRTYP,(R0)	;Test access type
	BNE 1$
	JSR PC,MFRAME		;If necessary make a new frame header
1$:	MOV 2(R0),R2		;R2 ← LOC[first frame header]
	JSR PC,RTLEVS		;return the offset to he 10
	JSR PC,GTINT		;Get second frame offset
	JSR PC,GETARG		;R0 ← LOC[environment entry]
	BIT #HDRTYP,(R0)	;Test access type
	BNE 2$
	JSR PC,MFRAME		;If necessary make a new frame header
2$:	MOV 2(R0),R1		;R1 ← LOC[second frame header]
	MOV @(R4),@INTPTR	;Get affixment code and return it
	ADD #2,INTPTR		;increment the integer pointer
	JMP AFFIX0		;jump into main affix routine and return from there

PUNFIX:
COMMENT ⊗ return the offsets of the two top elements on the
	stack and unfix them
	⊗
	MOV #2,4$
	SNDINT #XUNFIX		;return unfix code
	JSR PC,RTLEVS		;return offset to the 10
	JSR PC,GTINT		;Get first frame offset
	JSR PC,GETARG		;R0 ← LOC[environment entry]
	BIT #HDRTYP,(R0)	;Check header exists
	BEQ 1$			;  if not quit
	MOV 2(R0),R2		;R2 ← LOC[first frame header]
	DEC 4$
1$:	JSR PC,RTLEVS		;return offset of the second frame
	JSR PC,GTINT		;Get second frame offset
	JSR PC,GETARG		;R0 ← LOC[environment entry]
	BIT #HDRTYP,(R0)	;Check header exists
	BEQ 2$			;  if not quit
	MOV 2(R0),R1		;R1 ← LOC[second frame header]
	DEC 4$
2$:	BEQ 3$
	JMP UNFIX0		; jump into main interpreter routine returning from there
3$:	RTS PC			; return from here

DATA
4$:	0
CODE
; display: DISVT05

DISVT05:
	FETCH <R0>
	TST R0			;R0=0 → display - R0=1 → nodisplay
	BNE 1$			;go to stop display
	MOVB #COFF+30,CURYXAL	;trick display routine to think we are at bottom
	MOV #1,FRMDDT		;forces display to update titles
1$:	MOV R0,DSPOK
	RTS PC
; relative jumps: RFRCHK,RJMP,RJMPC
COMMENT ⊗ These routines are parallel to the jump and transfer of control
	routines in AL.  The relative jumps are needed to produce
	position independent pcode for the bodies of procedures
	⊗

RFRCHK:		; copied from FORCHK in INTRP.PAL
;Assume that the stack has, from surface in, the increment, the
;  final value, and the control variable's value, all of which are
;  scalar values.  If (FINAL-CONVAR)*(INCREMENT) ≥ 0 then this is a
;  no-op; otherwise, jump to the destination. 
;Arguments:  destination.	***** offset for control variable, destination *****
;******	MOV 4(R3),-(R3)	;Copy the control variable's value
;******	JSR PC,CHNGE	;Go update it
	LDF @2(R3),AC0	;AC0 ← final value
	SUBF @4(R3),AC0	;AC0 ← final - current
	MULF @(R3),AC0	;AC0 ← (final - current)*increment
	FETCH R0	;R0 ← destination offset ******** differs from FORCHK
	ASL R0		; to change to bytes
	CFCC
	BGE 1$		;Shall this be a no-op?
	BACKIPC		; since IPC is now pointing to next instruction
	ADD R0,IPC(R4)	;No; set new IPC. ******* in FORCHK this is MOV
;******	ADD #6,R3	;Pop the inc, final & control var off of the stack ****
1$:	CLR R0
	RTS PC		;Done

RJMP:
;Takes one argument: the relative offset of new address.
	MOV @IPC(R4),R0	; get the offset
	ASL R0		; change to bytes
	ADD R0,IPC(R4)	; increment IPC by the offset
	CCC		;Clear condition code.
	RTS PC		;Done

RJMPC:	;Parallel to JUMPC in INTERP.PAL[AL,HE]
	LDF	@(R3)+,AC0	;Get value of boolean
	CFCC			;copy condition codes
	BEQ	1$		;if false succeed - take branch
	BMPIPC			;skip over address
	RTS	PC		; & return
1$:	MOV	@IPC(R4),R0	; get the offset
	ASL	R0		; change to bytes
	ADD	R0,IPC(R4)	; branch
	RTS	PC		; & return

; relative printing: RPRINT
RPRINT:	MOV @IPC(R4),R0
	ASL R0
	ADD IPC(R4),R0	; put absolute address into R0 of string
	BMPIPC
	JMP PRINT0

; supplementary motions: pmove,tadrive,tddrive,gather,rforce,setstf
COMMENT ⊗
PMOVE:	MOV	LPMOVE,R2	; set for runtime move
	JMP	MOVSTA		; use common move code

TADRIVE: MOV	LTADRIVE,R2	; set for joint absolute motion
	JMP	MOVSTA

TDDRIVE: MOV	LTDDRIVE,R2	; set for joint relative motion
	JMP 	MOVSTA

	⊗
RPMOVE:	MOV	LRPMOVE,R2	;set for position independent pcode
	JMP	MOVST2

RTADRIVE:
	MOV	LRTADRIVE,R2
	JMP	MOVST2

RTDDRIVE:
	MOV	LRTDDRIVE,R2
	JMP	MOVST2

RCENTER:
	MOV	LRCENTER,R2
	JMP	MOVST2

MOVST2:	MOV	#XMOVE,@INTPTR	;code for move
	MOV	INTPTR,SVPTR	;save the current pointer
	ADD	#2,INTPTR	;increment pointer
	MOV	INTPTR,-(SP)	;save the pointer
	CLR	RPFLAG		;clear the retry flag
	JSR	PC,MOVSTA	;perform the motion
	TST	RPFLAG		;did we go through a retry?
	BNE	2$		;yes, we did
	CMP	INTPTR,(SP)+	;no, satisfactory move(check if move incremented
				;pointers
	BNE	1$		;yes, don't add anything
	CLR	@INTPTR		;no, clear next two words
	ADD	#2,INTPTR
	CLR	@INTPTR
	ADD	#2,INTPTR
1$:	RTS	PC		;return
2$:	MOV	SVPTR,INTPTR	;we went through a retry, back up
	TST	(SP)+		;pop the stack
	RTS	PC
DATA
SVPTR:	0			;used in case we do a RETRY$G
RPFLAG:	0			;checks if we did a RETRY$G
CODE

GATHER:	FETCH <R0>
	MOV  #FPPTR,R1	;address of FP buffer
	MOV  #INTPTR,R2	;address of INTEGER buffer
	JSR  PC,@LGATHER	; now go call the appropriate routine
	RTS  PC

RFORCE:	SNDINT #XRFORCE		;send back a xrforce
	MOV  #INTPTR,R1		;address of integer buffer
	JSR  PC,@LRFORCE
	CCC
	RTS PC

SETSTF:	MOV  #1$+24.,R0		; address of arguments
	MOV  #6,R1		; six of them
2$:	LDF  @(R3)+,AC0		; get the argument
	STF  AC0,-(R0)		; put in the right place
	SOB  R1,2$
;	MOV  #1$,R0		; let R0 point to the right place
				; R0 will be pointing to the right place
	JSR  PC,@LSETSTF	; jump into the arm code
	CCC
	RTS  PC			; and return
DATA
1$:	.BLKW	12.		; space for 6 real numbers
CODE
; supplementary functions: uparrow,dwnarrow,alpha,dollar,swap,vneg,vsmul,ftof
UPARROW: MOV	#ZHAT,-(R3)	; ↑ z-axis pointing upward, current frame or trans
	MOV	2(R3),R0	; get original trans value
	LDF	(R0),AC0
	MULF	AC0,AC0		; (1,1)↑2
	LDF	4(R0),AC1
	MULF	AC1,AC1		; (2,1)↑2
	ADDF	AC1,AC0		; ACO←(1,1)↑2+(2,1)↑2
	CMPF	C0001,AC0	; If AC0<C001 skip ahead
	CFCC
	BGT	1$
	CLRF	AC0
	SUBF	10(R0),AC0	; -(3,1)
	JSR	PC,@LASIN	; take arc-sin
	BR	2$
1$:	LDF	34(R0),AC0
	LDF	30(R0),AC1
	JSR	PC,@LATAN2	; take arc-tan2( (2,3),(1,3))
2$:    	JSR	PC,GETSCA	;R0 ← -(R3) ← LOC[new scalar block]
	STF	AC0,@(R3)	;Store result
	BR	DW3		;produce the rot

DOLLAR:	MOV	#NILROT,-(R3)	; $ station orientation, i.e. nilrot
	BR	DW2

ALPHA:	MOV	#ZHAT,-(R3)	; bgrasp orien at bpark, e.e. rot(zhat,180)
	BR	DW1

DWNARROW: MOV	#YHAT,-(R3)	; ↓ bpark orien, i.e. rot(yhat,180)
DW1:	MOV	#F180,-(R3)	; rot of 180 deg
DW3:	JSR	PC,VSAXWR	; return rot(vect,180) on stack
DW2:	JSR	PC,SWAP		; turn the top two elements around
	JSR	PC,TPOS		; take the position value of previous frame
	JSR	PC,TMAKE	; produce the transform
	RTS	PC		; and return

VNEG:	MOV	(R3),-(R3)	; copy the vector on the stack
	MOV	#NILVEC,2(R3)	; put in nilvector
	JMP	VSUB

VSMUL:	JSR	PC,SWAP		; reverse the two top elements
	JMP	SVMUL		; exit from SVMUL

SWAP:	MOV	(R3),-(SP)	; switch positions of top two elementsof stack
	MOV	2(R3),(R3)
	MOV	(SP)+,2(R3)
	RTS	PC

WRT:	JSR	PC,TORIEN	; v wrt t = orient(t)*v
VFREL:	JSR	PC,SWAP		; v rel f = t*v
	JMP	TVMUL

FTOF:	JSR	PC,SWAP		;t1→t2 = inv(t1)*t2
	JSR	PC,TINVRT
FFREL:	JSR	PC,SWAP		; f rel t = t*f
	JMP	TTMUL
				; take positions of three frames and put them
				; to the stack
FCONSTR: MOV	(R3)+,-(SP)	; save top two elements
	MOV	(R3)+,-(SP)
	JSR	PC,TPOS		; find position of frame 1
	MOV	(SP)+,-(R3)
	JSR	PC,TPOS		; find position of frame 2
	MOV	(SP)+,-(R3)
	JSR	PC,TPOS		; find position of frame 3
	JMP	CONSTR

; functions: sqrt,sin,cos,asin,acos,tan,atan2,log,exp
PSQRT:	LDF @(R3)+,AC0	;AC0 ← arg
	JSR	PC,SQRT
	JMP	SRET

PSIN:	LDF @(R3)+,AC0	;AC0 ← arg
	JSR	PC,SIN
	JMP	SRET

PCOS:	LDF @(R3)+,AC0	;AC0 ← arg
	JSR	PC,COS
	JMP	SRET

PTAN:	LDF @(R3)+,AC0	;AC0 ← arg
	JSR	PC,TAN
	JMP	SRET

PASIN:	LDF @(R3)+,AC0	;AC0 ← arg
	JSR	PC,ASIN
	JMP	SRET

PACOS:	LDF @(R3)+,AC0	;AC0 ← arg
	JSR	PC,ACOS
	JMP	SRET

PATAN2:	JSR	PC,SWAP
	LDF @(R3)+,AC0	;AC0 ← arg
	JSR	PC,ATAN2
	JMP	SRET

PLOG:	LDF @(R3)+,AC0	;AC0 ← arg
	JSR	PC,LOG
	JMP	SRET

PEXP:	LDF @(R3)+,AC0	;AC0 ← arg
	JSR	PC,EXP
	JMP	SRET
; procedure handling: GTBLK

GTBLK:
COMMENT ⊗
	 GTBLK n ..... q 
	n is size of the block of pcode to be copied
	 ..... is n words of information
	 the address of the block is to be put at the location of q + offset q
	⊗
	FETCH	<R0>		; get size of the block to get
	MOV	R0,R2		;
;	ADD	R0,R0		; get size in bytes
	JSR	PC,GTFREE	; get the size we need
	MOV	R0,-(SP)	; save the address of the block
1$:	FETCH	<R1>		; get word to transfer
	MOV	R1,(R0)+	; transfer to new area
	SOB	R2,1$
	MOV	@IPC(R4),R1	; now get the offset in which to stick the address of this block
	ASL	R1		; get it in bytes
	ADD	IPC(R4),R1	; get the absolute address
	BMPIPC
	MOV	(SP)+,(R1)	; write into the pcode ####### ... careful !
	RTS	PC		; and return

; more stack ops: gtint,gvals,chngs

APUSHOFFSET:
	JSR PC,PUSHINITI	; push index onto stack
PUSHOFFSET:
AREF:
; The argument is an integer. Make a scalar record and store the offset value
; on that stack.
; this routine is used in conjunction with GVALS and CHNGS
	JMP PUSHINTI

GTINT:	LDF	@(R3)+,AC0	;Get value of top element of stack
	STCFI	AC0,R0		;Convert it to integer & store it in R0
	RTS 	PC

GVALS:	JSR	PC,GTINT	; get the value of variable whose offset is on stack
	JMP	GVAL0

CHNGS:	JSR	PC,GTINT	; change the value of the variable whose offset is on stack
	JMP	CHNG0

TACK:	RTS	PC		; dummy routine for interp call

DATA
HLTMSG:	0
CODE
; return from POINTY : pdone 

PDONE:
	MOV RF,SP		;Restore stack
	MOV -2(SP),RF		;RF ← old PC
	RTS RF			;Just return